home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / menusAndKeys.tcl < prev    next >
Encoding:
Text File  |  1998-12-16  |  26.4 KB  |  854 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  Alpha - new Tcl folder configuration
  4.  # 
  5.  #  FILE: "menusAndKeys.tcl"
  6.  #                                    created: 12/9/97 {1:43:22 pm} 
  7.  #                                last update: 16/12/1998 {2:13:45 pm} 
  8.  #  Author: Vince Darley
  9.  #  E-mail: <darley@fas.harvard.edu>
  10.  #    mail: Division of Engineering and Applied Sciences, Harvard University
  11.  #          Oxford Street, Cambridge MA 02138, USA
  12.  #     www: <http://www.fas.harvard.edu/~darley/>
  13.  #  
  14.  # Reorganisation carried out by Vince Darley with much help from Tom 
  15.  # Fetherston, Johan Linde and suggestions from the Alpha-D mailing list.  
  16.  # Alpha is shareware; please register with the author using the register 
  17.  # button in the about box.
  18.  #  
  19.  # 
  20.  #  modified by  rev reason
  21.  #  -------- --- --- -----------
  22.  #  27/11/97 FBO x.x make keys::keyboardChanged use one more item in keyboards
  23.  # ###################################################################
  24.  ##
  25.  
  26. namespace eval menu {}
  27. namespace eval keys {}
  28. namespace eval bind {}
  29.  
  30. ## 
  31.  # -------------------------------------------------------------------------
  32.  # 
  33.  # "menu::bind" --
  34.  # 
  35.  #  Convert a preference of type 'binding' or 'menubinding' into a code
  36.  #  to be inserted into a menu.  Menu-bindings are guaranteed to succeed.
  37.  #  If an ordinary binding contains a prefixChar (e.g. you have bound
  38.  #  ctrl-c followed by ctrl-x to something), then this procedure will
  39.  #  return an empty string, since such bindings cannot appear in menus.
  40.  #  Finally if it is a key-binding and it does not contain a modifier
  41.  #  key, and the key is a normal key (not F1-F12 + few others), then
  42.  #  it will appear in the menu, but the menu will not activate with
  43.  #  that key.  On MacOS, menus can only activate with key-presses
  44.  #  which include a modifier.
  45.  #  
  46.  #  Example usage (from the modeSearchPaths package):
  47.  #  
  48.  #     newPref binding openSelection "<O<B/H" searchPaths
  49.  #     newPref binding sourceHeaderToggle "<O/f" searchPaths
  50.  #   menu::addTo fileUtils \
  51.  #        "[menu::bind searchPathsmodeVars(sourceHeaderToggle) -]" \
  52.  #        "[menu::bind searchPathsmodeVars(openSelection) -]"
  53.  #  
  54.  #  You can adjust these bindings in the package preferences dialog,
  55.  #  but changes will not take effect until you restart Alpha.  Note
  56.  #  that if the user selected menu-incompatible bindings, they would
  57.  #  not operate without the addition of some code to Bind them.  One
  58.  #  would need to add this:
  59.  #  
  60.  #   eval Bind \
  61.  #     [keys::toBind $searchPathsmodeVars(sourceHeaderToggle)] \
  62.  #     file::sourceHeaderToggle
  63.  #   
  64.  #  The optional arg is the rest of the menu item or '-' which means
  65.  #  use the variable name (if a var) or array element (if an array).
  66.  #  
  67.  #  If the optional argument is given, and the menu item therefore
  68.  #  contains a '/', it is considered to be two dynamic items, the
  69.  #  second of which requires the option key to be used.
  70.  #  
  71.  #  Similarly '//' means use shift, '///' means shift-option,
  72.  #  For instance 'set v /W<O ; menu::bind v close/closeAll//closeFloat'
  73.  #  would give you the menu-item for 'close' in the file menu. 
  74.  # -------------------------------------------------------------------------
  75.  ##
  76. proc menu::bind {var {item ""}} {
  77.     upvar \#0 $var a
  78.     if {[regexp {«(.*)»} $a]} { set ret "" } else { set ret $a }
  79.     if {$item != ""} {
  80.     if {$item == "-"} {
  81.         regsub -all {([a-zA-Z_:]+\(|\))} $var {} item
  82.     }
  83.     if {[regexp {/} $item]} {
  84.         set item "<S<E<K$item"
  85.         regsub {///} $item " <S<I<U<K" item
  86.         regsub {//} $item " <S<U<K" item
  87.         regsub {/} $item " <S<I<K" item
  88.         regsub -all {<K} $item $ret ret
  89.     } else {
  90.         append ret $item
  91.     }
  92.     }
  93.     return $ret
  94. }
  95.  
  96. # ◊◊◊◊ flags-menus from prefs ◊◊◊◊ #
  97. # The following four procs allow you to create flag menus with ticks
  98. # very simply.  They adhere to the basic idea of the 'newPref' facility.
  99. proc menu::makeFlagDummy {name {type list}} {
  100.     switch -- $type {
  101.     "array" {
  102.         return [list Menu -n $name -p menu::flagProc {}]
  103.     }
  104.     "list" {
  105.         return [list Menu -m -n $name -p menu::flagProc {}]
  106.     }
  107.     }
  108. }
  109.  
  110. proc menu::makeFlagMenu {name {type list} {var ""} {in_array ""} \
  111.   {nonFlagProc ""} {prologue ""} {epilogue ""}} {
  112.     if {$var == ""} { set var $name }
  113.     switch -- $type {
  114.     "array" {
  115.         global $var menu::flagArray allFlags
  116.         set menu::flagArray($name) \
  117.           [list "array" $var "" $nonFlagProc]
  118.         foreach i [lsort [array names $var]] {
  119.         if {[lsearch -exact $allFlags $i] != -1} {
  120.             lappend items [lindex [list "$i" "!•$i"] [set ${var}($i)]]
  121.         }
  122.         }
  123.         if {[info tclversion] >= 8.0} {
  124.         return [list Menu -t checkbutton -n $name -p menu::flagProc $items]
  125.         } else {
  126.         return [list Menu -n $name -p menu::flagProc $items]
  127.         }
  128.     }
  129.     "list" {
  130.         global $var menu::flagArray
  131.         if {$in_array != ""} {
  132.         set menu::flagArray($name) [list "list" $in_array $var $nonFlagProc]
  133.         global $in_array
  134.         set val [set ${in_array}($var)]
  135.         } else {
  136.         set menu::flagArray($name) \
  137.           [list "list" $var "" $nonFlagProc]
  138.         set val [set $var]
  139.         }
  140.         set i [lsearch -exact [set items [flag::options $var]] $val]
  141.         if {$i != -1} {
  142.         set items [lreplace $items $i $i "!•[lindex $items $i]"]
  143.         }
  144.         if {$prologue != ""} {
  145.         set items [concat $prologue [expr {[llength $items] ? {(-} : ""}] $items]
  146.         } 
  147.         if {$epilogue != ""} {
  148.         set items [concat $items [expr {[llength $items] ? {(-} : ""}] $epilogue]
  149.         }
  150.         if {[info tclversion] >= 8.0} {
  151.         return [list Menu -m -t radiobutton -n $name -p menu::flagProc $items]
  152.         } else {
  153.         return [list Menu -m -n $name -p menu::flagProc $items]
  154.         }
  155.     }
  156.     default {
  157.         error "Other types not yet supported"
  158.     }
  159.     }
  160. }
  161.  
  162. proc menu::stripMetaChars {menuItems} {
  163.     set strippedItems ""
  164.     
  165.     foreach menuItem $menuItems {
  166.     regsub -all {<(B|I|U|O|S|E)} $menuItem "" menuItem
  167.     regsub -all {/.} $menuItem "" menuItem
  168.     regsub -all {!.} $menuItem "" menuItem
  169.     regsub -all {\^.} $menuItem "" menuItem
  170.     regsub -all {…$} $menuItem "" menuItem
  171.     lappend strippedItems $menuItem
  172.     }
  173.     
  174.     return $strippedItems
  175. }
  176.  
  177. proc menu::buildFlagMenu {name args} {
  178.     eval [eval menu::makeFlagMenu [list $name] $args]
  179. }
  180.  
  181. proc menu::flagProc {menu flag} {
  182.     global menu::flagArray flag::procs modifiedArrayElements modifiedVars
  183.     set type [set menu::flagArray($menu)]
  184.     
  185.     set name [lindex $type 1]
  186.     upvar \#0 $name a
  187.     switch -- [lindex $type 0] {
  188.     "array" {
  189.         if {[lsearch -exact [array names a] $flag] == -1} {
  190.         [lindex $type 3] $menu $flag 
  191.         } else {
  192.         set a($flag) [expr {1 - $a($flag)}]
  193.         if {[info exists flag::procs($flag)]} {
  194.             [set flag::procs($flag)] $flag
  195.         }
  196.         message "$menu item '$flag' set to $a($flag)"
  197.         markMenuItem $menu $flag $a($flag)
  198.         lunion modifiedArrayElements [list $flag $name]
  199.         }
  200.     }
  201.     "list" {
  202.         # array entries are indexed by the '2' element.
  203.         if {[set var [lindex $type 2]] == ""} { set var $name }
  204.         
  205.         if {[lsearch -exact [flag::options $var] $flag] == -1} {
  206.         [lindex $type 3] $menu $flag 
  207.         } else {
  208.         if {[set b [lindex $type 2]] == ""} {
  209.             markMenuItem $menu $a off
  210.             set a $flag
  211.             lunion modifiedVars [lindex $type 1]
  212.             message "[lindex $type 1] set to $flag"
  213.         } else {
  214.             markMenuItem $menu $a($b) off
  215.             set a($b) $flag
  216.             lunion modifiedArrayElements [list [lindex $type 2] [lindex $type 1]]
  217.             message "$menu set to $flag"
  218.         }
  219.         markMenuItem $menu $flag on
  220.         if {[info exists flag::procs([lindex $type 1])]} {
  221.             [set flag::procs([lindex $type 1])] $flag
  222.         }
  223.         }
  224.     }
  225.     }
  226. }
  227.  
  228. # ◊◊◊◊ Bindings ◊◊◊◊ #
  229.  
  230. proc menu::bindingsFromArray {arr {include_empty 0}} {
  231.     upvar $arr ar
  232.     set r {}
  233.     foreach a [array names ar] {
  234.     if {[set b $ar($a)] != "" || $include_empty} {
  235.         lappend r "$b$a"
  236.     }
  237.     }
  238.     return $r
  239. }
  240.  
  241. proc bind::fromArray {arr bindarr {unbind 0} {mode {}}} {
  242.     upvar $arr ar
  243.     upvar $bindarr br
  244.     set r {}
  245.     if {$unbind} {
  246.     set bindcmd "unBind"
  247.     } else {
  248.     set bindcmd "Bind"
  249.     }
  250.     foreach a [array names ar] {
  251.     if {[set b $ar($a)] != ""} {
  252.         if {[info exists br($a)]} {
  253.         catch {eval $bindcmd [keys::toBind $b] [list $br($a)] $mode}
  254.         } else {
  255.         beep; message "Bad bind-array entry '$a'"
  256.         }
  257.     }
  258.     }
  259. }
  260.  
  261. ### 
  262.  # -------------------------------------------------------------------------
  263.  # 
  264.  # "keys::verboseKey" --
  265.  # 
  266.  #  Turn a string containing a menu key-code '/x' into a verbose description
  267.  #  of that key.  The optional parameter declares a variable whose value
  268.  #  will be set if the key is a normal key.
  269.  # -------------------------------------------------------------------------
  270.  ##
  271. proc keys::verboseKey {kstr {normal {}}} {
  272.     if {$normal != ""} {upvar $normal n ; set n 0}
  273.     if {![regexp {/(Kpad)(.)} $kstr "" key pad] && ![regexp {/(.)} $kstr "" key]} { return "" }
  274.     switch -regexp -- $key {
  275.     {Kpad} {return "Key pad $pad"}
  276.     {[a-z]} {
  277.         global keys::func
  278.         return [lindex ${keys::func} [expr {[text::Ascii $key] - 97}]]
  279.     }
  280.     "" {
  281.         return "Left"
  282.     }
  283.     "" {
  284.         return "Right"
  285.     }
  286.     "\x10" {
  287.         return "Up"
  288.     }
  289.     "" {
  290.         return "Down"
  291.     }
  292.     " " {
  293.         return "Space"
  294.     }
  295.     default {
  296.         set n 1
  297.         return $key
  298.     }
  299.     }
  300. }
  301.  
  302. set keys::func {Enter Return Tab "Num Lock" F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 \
  303.   F11 F12 F13 F14 F15 Help Delete "Fwd Del" Home End "Page Up" "Page Down"}
  304.  
  305. set keys::ascii {0x03 0x0d 0x09 0 0 0 0 0 0 0 0 0 0 0 \
  306.   0 0 0 0 0 0 0x08 0 0 0 0 0}
  307.  
  308. set keys::bind {Enter 0x24 0x30 Clear F1 F2 F3 F4 F5 F6 F7 F8 F9 F10 \
  309.   F11 F12 F13 F14 F15 Help 0x33 Del Home End Pgup Pgdn}
  310.  
  311. ## 
  312.  # -------------------------------------------------------------------------
  313.  # 
  314.  # "keys::toBind" --
  315.  # 
  316.  #  Turn a menu key-modifier sequence into something suitable for
  317.  #  a 'bind' statement.  Copes with function keys and arrow keys.
  318.  #  
  319.  #  Use a couple of strings to perform shift-mappings, so that although
  320.  #  the binding says it's bound to 'shift-1', say, in fact it must be
  321.  #  bound to '!' (or shift-'!' which are equivalent), since '!' is a 
  322.  #  shifted '1'.
  323.  #  
  324.  #  You can use 'addcode' to add modifiers.  Mostly useful for pairs
  325.  #  of bindings stored in a single pref in which one is an option/shift
  326.  #  modified version of the other.
  327.  # -------------------------------------------------------------------------
  328.  ##
  329. proc keys::toBind {kstr {addcode {}}} {
  330.     if {![regexp {/(Kpad.)$} $kstr "" key] && ![regexp {/(.)} $kstr "" key]} { return "" }
  331.     if {![string match Kpad* $key] && [regexp {[a-z]} $key]} {
  332.     global keys::bind
  333.     set key [lindex ${keys::bind} [expr {[text::Ascii $key] - 97}]]
  334.     } elseif {[set i [lsearch -exact {" " "" "" "\x10" ""} $key]] != -1} {
  335.     set key [lindex {0x31 0x7b 0x7c 0x7e 0x7d} $i]
  336.     } elseif {![string match Kpad* $key]} {
  337.     set key [string tolower $key]
  338.     }
  339.     if {[string length $key] == 1} {
  340.     global keys::mapShiftBindFrom keys::mapShiftBindTo
  341.     if {[regexp {[a-z]} $key] || ![regexp {^<U/} $kstr]} {
  342.         set key '${key}' 
  343.     } elseif {[set i [string first $key ${keys::mapShiftBindFrom}]] != -1} {
  344.         set key '[string index ${keys::mapShiftBindTo} $i]'
  345.     } else {
  346.         #alertnote "Weird key: $kstr, please tell Vince."
  347.         # Note from Vince: I think it's ok just to assume we can
  348.         # bind to the key like this, but it's possible there are
  349.         # some problems on international keyboards.  With a U.S.
  350.         # keyboard we should NEVER get here.
  351.         set key '${key}'
  352.     }
  353.     }
  354.     global keys::international
  355.     if {[info exists keys::international($key)]} {
  356.     set key [set keys::international($key)]
  357.     }
  358.     if {[set a [keys::modifiersTo $kstr$addcode bind]] != ""} {
  359.     return [list $key $a]
  360.     } else {
  361.     return [list $key]
  362.     }
  363. }
  364.  
  365. ## 
  366.  # -------------------------------------------------------------------------
  367.  # 
  368.  # "keys::keyboardChanged" --
  369.  # 
  370.  #  When we change the value of 'keyboards' in the international prefs,
  371.  #  this is called, with the parameter 'keyboards'.
  372.  #  
  373.  #  It is also called at startup, with no parameter.
  374.  #  
  375.  #  Frédéric Boulanger <Frederic.Boulanger@supelec.fr> Nov 27 1997
  376.  #    Added one item to the keyboards items: a list of characters followed
  377.  #    by corresponding key codes.
  378.  #    keys::keyboardChanged now looks for these items and sets 
  379.  #    keys::international to the corresponding key code for each character
  380.  #    in the first list. This is so keys::toBind returns a key code 
  381.  #    instead of a character, which makes Bind only Bind the given character
  382.  #    and leave the shifted char unbound. The problem arose on a french 
  383.  #    keyboard where '{' is '(' <o> and '[' is '(' <os> . Binding '(' <o>
  384.  #    to bind::LeftBrace also binds '(' <os> to bind::LeftBrace, so it was
  385.  #    impossible to type a '['. To avoid this problem, we have to Bind
  386.  #    0x17 <o> to bind::LeftBrace, where 0x17 is the key code for '(' on a
  387.  #    french keyboard.
  388.  #    For other keyboards, I don't know the key codes, so if you have the
  389.  #    same problem with bindings, you may change the definition of your 
  390.  #    keyboard in alphaDefinitions.tcl to solve it.
  391.  # -------------------------------------------------------------------------
  392.  ##
  393. proc keys::keyboardChanged {{flag "startup"}} {
  394.     global keyboards keyboard keys::mapShiftBindFrom keys::mapShiftBindTo \
  395.       modifiedVars oldkeyboard bind::LeftBrace bind::RightBrace keys::international
  396.     if {$oldkeyboard != ""} {
  397.     catch "unBind [keys::toBind ${bind::LeftBrace}] bind::LeftBrace"
  398.     catch "unBind [keys::toBind ${bind::RightBrace}] bind::RightBrace"
  399.     set i 0
  400.     foreach k [lindex $keyboards($oldkeyboard) 4] {
  401.         if {[incr i] % 2} {catch {unset keys::international($k)}}
  402.     }
  403.     catch {unset keys::international}
  404.     hook::callAll removekeyboard $oldkeyboard
  405.     }
  406.     # set new values
  407.     set keys::mapShiftBindFrom [lindex $keyboards($keyboard) 0]
  408.     set keys::mapShiftBindTo [lindex $keyboards($keyboard) 1]
  409.     set bind::LeftBrace [lindex $keyboards($keyboard) 2]
  410.     set bind::RightBrace [lindex $keyboards($keyboard) 3]
  411.     if {[llength $keyboards($keyboard)] >= 5} {
  412.     array set keys::international [lindex $keyboards($keyboard) 4]
  413.     }
  414.     # Bind
  415.     catch "Bind [keys::toBind ${bind::LeftBrace}] bind::LeftBrace"
  416.     catch "Bind [keys::toBind ${bind::RightBrace}] bind::RightBrace"
  417.     # Call anything that's been registered to the new keyboard
  418.     # (Usually a proc to change some menu-bindings).  Use:   
  419.     #   hook::register keyboard "Swiss French" my-proc
  420.     hook::callAll keyboard $keyboard
  421.     if {$oldkeyboard != ""} {
  422.     lappend modifiedVars keyboard
  423.     alertnote "Changing the keyboard may require you to restart\
  424.       Alpha for the bindings to be set correctly."
  425.     }
  426.     set oldkeyboard $keyboard
  427. }
  428.  
  429. proc bind::fromPref {f {un ""}} {
  430.     global flag::binding
  431.     if {[info exists flag::binding($f)]} {
  432.     set m [lindex [set flag::binding($f)] 0]
  433.     if {[set proc [lindex [set flag::binding($f)] 1]] == 1} {
  434.         set proc $f
  435.     }
  436.     namespace eval ::alpha [list catch "${un}Bind [keys::toBind $old] [list $proc] $m"]
  437.     }
  438. }
  439.  
  440. ## 
  441.  # -------------------------------------------------------------------------
  442.  # 
  443.  # "keys::modifiersTo" --
  444.  # 
  445.  #  Turn a menu-modifier sequence into something else.  Options are 
  446.  #  'verbose' (a textual description), 'bind' (a binding code-sequence),
  447.  #  and 'menu' which just returns what was given.
  448.  # -------------------------------------------------------------------------
  449.  ##
  450. proc keys::modifiersTo {key type} {
  451.     set key1 {}
  452.     switch -- $type {
  453.     "verbose" {
  454.         if {[regexp {«(.)»} $key d pref]} {
  455.         if {$pref == "e"} {
  456.             append key1 "escape "
  457.         } else {
  458.             append key1 "ctrl-$pref "
  459.         }
  460.         }
  461.         if {[regexp {<U} $key]} {append key1 "shift-"}
  462.         if {[regexp {<B} $key]} {append key1 "ctrl-"}
  463.         if {[regexp {<I} $key]} {append key1 "opt-"}
  464.         if {[regexp {<O} $key]} {append key1 "cmd-"}
  465.         return $key1
  466.     }
  467.     "tksym" {
  468.         if {[regexp {«(.)»} $key d pref]} {
  469.         if {$pref == "e"} {
  470.             append key1 "Escape "
  471.         } else {
  472.             append key1 "Control-$pref "
  473.         }
  474.         }
  475.         if {[regexp {<U} $key]} {append key1 "Shift-"}
  476.         if {[regexp {<B} $key]} {append key1 "Control-"}
  477.         if {[regexp {<I} $key]} {append key1 "Option-"}
  478.         if {[regexp {<O} $key]} {append key1 "Command-"}
  479.         return $key1
  480.     }
  481.     "bind" {
  482.         if {[regexp {<U} $key]} {append key1 "s"}
  483.         if {[regexp {<B} $key]} {append key1 "z"}
  484.         if {[regexp {<I} $key]} {append key1 "o"}
  485.         if {[regexp {<O} $key]} {append key1 "c"}
  486.         if {[regexp {«(.)»} $key d pref]} {
  487.         append key1 $pref
  488.         }
  489.         if {$key1 != ""} {
  490.         return "<${key1}>"
  491.         } else {
  492.         return ""
  493.         }
  494.     }
  495.     "menu" {
  496.         if {[regexp {«(.)»} $key d pref]} {
  497.         return ""
  498.         } else {
  499.         return $key
  500.         }
  501.     }
  502.     }
  503. }
  504.  
  505. ## 
  506.  # -------------------------------------------------------------------------
  507.  # 
  508.  # "keys::bindToMenu" --
  509.  # 
  510.  #  Doesn't yet cope with function keys etc, nor 0x31 type bindings,
  511.  #  nor prefixChars (which can't go in a menu anyway).
  512.  # -------------------------------------------------------------------------
  513.  ##
  514. proc keys::bindToMenu {i} {
  515.     regexp {'(.)'[ \t]*<([^>]+)>} $i d key mods
  516.     set key "/[string toupper $key]"
  517.     if {[regexp {s} $mods]} {append key "<U"}
  518.     if {[regexp {z} $mods]} {append key "<B"}
  519.     if {[regexp {o} $mods]} {append key "<I"}
  520.     if {[regexp {c} $mods]} {append key "<O"}
  521.     return $key
  522. }
  523.     
  524. ## 
  525.  # -------------------------------------------------------------------------
  526.  # 
  527.  # "keys::findPrefixChars" --
  528.  # 
  529.  #  This proc is rather slow, since it has to scan an enormous list of
  530.  #  bindings.  However since it is only used from the dialog below,
  531.  #  that doesn't matter too much (i.e. it is quick enough on my machine).
  532.  # -------------------------------------------------------------------------
  533.  ##
  534. proc keys::findPrefixChars {} {
  535.     set menu ""
  536.     foreach i [keys::findBindingsTo "prefixChar"] {
  537.     if {![regexp {'(.)'[ \t]*<z>} $i d key]} {
  538.         beep; message "A bad prefix char has been defined: Bind $i prefixChar, this will not work."
  539.     } else {
  540.         lappend menu [string toupper $key]
  541.     }
  542.     }
  543.     return $menu
  544. }
  545.  
  546. proc keys::findBindingsTo {to {mode ""} {lines 0}} {
  547.     if {$mode == "*"} { set mode "(\\w+)?" }
  548.     set t [bindingList]
  549.     set pref ""
  550.     while {[regexp -indices "\rBind(\[^\r\]+) $to *${mode} *\r" $t d idx]} {
  551.     if {$lines} {
  552.         lappend pref [string trim [eval string range [list $t] $d]]
  553.     } else {
  554.         lappend pref [string trim [eval string range [list $t] $idx]]
  555.     }
  556.     set t [string range $t [lindex $idx 1] end]
  557.     }
  558.     return $pref
  559. }
  560.  
  561. proc keys::findBindingsOf {of {mode ""}} {
  562.     if {$mode == "*"} { set mode "(\\w+)?" }
  563.     set t [bindingList]
  564.     set pref ""
  565.     while {[regexp -indices "\rBind[quote::WhitespaceReg " ${of} "](\[\\w:\]+) *${mode} *\r" $t l idx]} {
  566.     lappend pref [string trim [eval string range [list $t] $l]]
  567.     set t [string range $t [lindex $idx 1] end]
  568.     }
  569.     return $pref
  570. }
  571.  
  572. proc keys::unsetBinding {v {mode ""}} {
  573.     foreach i [keys::findBindingsOf $v $mode] {
  574.     regsub {' '} $i {0x31} i
  575.     eval "un${i}"
  576.     }
  577. }
  578.  
  579. proc keys::bindPackage {pkg} {
  580.     global ${pkg}modeVars flag::type flag::binding
  581.     foreach v [array names ${pkg}modeVars] {
  582.     if {[info exists flag::type($v)] && [set flag::type($v)] == "binding"} {
  583.         if {[info exists flag::binding($v)]} {
  584.         set m [lindex [set flag::binding($v)] 0]
  585.         if {[set proc [lindex [set flag::binding($v)] 1]] == 1} {
  586.             set proc $v
  587.         }
  588.         namespace eval ::alpha [list catch "Bind [keys::toBind [set ${pkg}modeVars($v)]] [list $proc] $m"]
  589.         }
  590.     }
  591.     }
  592. }
  593.  
  594. # ◊◊◊◊ Key presses ◊◊◊◊ #
  595. namespace eval key {}
  596.  
  597. proc key::optionPressed {{m ""}} {
  598.     if {$m == ""} {set m [getModifiers]}
  599.     return [expr {$m & 72}]
  600. }
  601. proc key::shiftPressed {{m ""}} {
  602.     if {$m == ""} {set m [getModifiers]}
  603.     return [expr {$m & 34}]
  604. }
  605. proc key::controlPressed {{m ""}} {
  606.     if {$m == ""} {set m [getModifiers]}
  607.     return [expr {$m & 144}]
  608. }
  609. proc key::cmdPressed {{m ""}} {
  610.     if {$m == ""} {set m [getModifiers]}
  611.     return [expr {$m & 1}]
  612. }
  613.  
  614. namespace eval prompt {}
  615. ## 
  616.  # -------------------------------------------------------------------------
  617.  # 
  618.  # "prompt::getAKey" --
  619.  # 
  620.  #  'getChar' is modified by ctrl and option, so if the user presses one
  621.  #  of them, we have to request the key again.  Also if the user pressed
  622.  #  shift and the key wasn't A-Z, then we also have to ask again.  Finally
  623.  #  if the key pressed was a non-ascii one, we have to select from a menu.
  624.  #  
  625.  #  This function is an alternative to 'dialog::getAKey'.  Hence it takes
  626.  #  the same parameters, except it ignores some of them.
  627.  #  
  628.  #  Doesn't currently deal with the 'for_menu' flag which it should.
  629.  # -------------------------------------------------------------------------
  630.  ##
  631. proc prompt::getAKey {{name ""} {keystr ""} {for_menu 1}} {
  632.     beep ; message "Press the key and modifiers"
  633.     set char [string toupper [getChar]]
  634.     set mod [getModifiers]
  635.     if {$mod & 0xd8 || ($mod & 0x22) && ![regexp {[A-Z]} $char]} {
  636.     beep; message "Please press the key again, this time without modifiers."
  637.     set char [string toupper [getChar]]
  638.     }
  639.     if {![regexp {[][=A-Z0-9`\\';,./-]} $char]} {
  640.     global keys::ascii keys::func
  641.     set ascii [text::Ascii $char]
  642.     if {$ascii > 27 && $ascii < 32} {
  643.         set char [lindex {"" "" "\x10" ""} [expr {$ascii - 27}]]
  644.     }
  645.     set i 0
  646.     foreach k ${keys::ascii} { 
  647.         if {[expr {$k == $ascii}]} { 
  648.         set char [text::Ascii [expr {$i + 97}] 1]
  649.         break
  650.         }
  651.         incr i
  652.     }
  653.     if {$i == [llength ${keys::ascii}]} {
  654.         set char [dialog::optionMenu \
  655.           "This procedure cannot isolate which key that was.  You'll have to select it manually" ${keys::func} "" 1]
  656.         set char [text::Ascii [expr {$char + 97}] 1]
  657.     }
  658.     }
  659.     set res [keys::modToMenu $mod $char]
  660.     if {!$for_menu} {
  661.     beep; message "If there is a prefix-char, hit that now (without the ctrl-key) else return."
  662.     set char [string toupper [getChar]]
  663.     if {[text::Ascii $char] == 27} { set char "e" } 
  664.     if {[regexp -nocase {[a-z]} $char]} {append res "«$char»"}
  665.     }
  666.     return $res
  667. }
  668.  
  669. ## 
  670.  # cmdKey                      = 0x01,
  671.  # shiftKey                    = 0x02,
  672.  # alphaLock                   = 0x04,
  673.  # optionKey                   = 0x08,
  674.  # controlKey                  = 0x10,
  675.  # rightShiftKey               = 0x20,
  676.  # rightOptionKey              = 0x40,
  677.  # rightControlKey             = 0x80,
  678.  ##
  679. # 'char' must be upper case, if it really is a char.
  680. proc keys::modToMenu {mod {char ""}} {
  681.     if {$char != ""} {
  682.     set t "/${char}"
  683.     } else {
  684.     set t ""
  685.     }
  686.     # cmd
  687.     if {[expr {$mod & 1}]} { append t "<O" }
  688.     # shift
  689.     if {[expr {$mod & 2 |  $mod & 32}]} { append t "<U" }
  690.     # option
  691.     if {[expr {$mod & 8 | $mod & 64}]} { append t "<I" }
  692.     # ctrl
  693.     if {[expr {$mod & 16 | $mod & 128}]} { append t "<B" }
  694.     return $t
  695. }
  696.  
  697. proc global::specialKeys {} {
  698.     global keys::specialBindings keys::specialProcs modifiedArrVars
  699.     # unbind old set
  700.     bind::fromArray keys::specialBindings keys::specialProcs 1
  701.     
  702.     if {[hook::callAll specialKeys *]} {
  703.     # rebind old set and return
  704.     bind::fromArray keys::specialBindings keys::specialProcs
  705.     return
  706.     }
  707.     
  708.     if {[catch {dialog::arrayBindings "Special keys" keys::specialBindings}]} {
  709.     # cancelled so rebind old set
  710.     bind::fromArray keys::specialBindings keys::specialProcs
  711.     return
  712.     }
  713.     # Bind new set
  714.     bind::fromArray keys::specialBindings keys::specialProcs
  715.     # perhaps do something else?
  716.     lappend modifiedArrVars keys::specialBindings
  717. }
  718.  
  719.  
  720. ## 
  721.  # -------------------------------------------------------------------------
  722.  # 
  723.  # "alpha::basicKeyBindings" --
  724.  # 
  725.  #  Bind all the obvious stuff, so cursor keys etc actually work!
  726.  # -------------------------------------------------------------------------
  727.  ##
  728. proc alpha::basicKeyBindings {} {
  729.     Bind Left  backwardChar
  730.     Bind Left <c> beginningOfLine
  731.     Bind Left <s> backwardCharSelect
  732.     Bind Left <sc> beginningLineSelect
  733.     Bind Left <z> {scrollLeftCol 15}
  734.     Bind Left <o> backwardWord
  735.     Bind Left <os> backwardWordSelect
  736.     
  737.     Bind Right  forwardChar
  738.     Bind Right <c> endOfLine
  739.     Bind Right <s> forwardCharSelect
  740.     Bind Right <sc> endLineSelect
  741.     Bind Right <z> {scrollRightCol 15}
  742.     Bind Right <o> forwardWord
  743.     Bind Right <os> forwardWordSelect
  744.     
  745.     Bind Up        previousLine
  746.     Bind Up <s>    prevLineSelect
  747.     Bind Up <c>    beginningOfBuffer
  748.     Bind Up <sc>   beginningBufferSelect
  749.     Bind Up <z>    scrollUpLine
  750.     Bind Up <o>    scrollUpLine
  751.     
  752.     Bind Down      nextLine
  753.     Bind Down <c>  endOfBuffer
  754.     Bind Down <s>  nextLineSelect
  755.     Bind Down <sc> endBufferSelect
  756.     Bind Down <z>  scrollDownLine
  757.     Bind Down <o>  scrollDownLine
  758.     
  759.     # Keypad definitions
  760.     Bind KPad4     backwardWord                 
  761.     Bind KPad4 <c> backwardDeleteWord 
  762.     Bind KPad6     forwardWord                 
  763.     Bind KPad6 <c> deleteWord 
  764.     Bind Clear     toggleNumLock
  765.     # Never Bind Keypad /
  766.     # Never Bind Keypad *
  767.     Bind KPad0     nextWindow
  768.     Bind KPad0 <s> prevWindow
  769.     Bind KPad+     nextWindow
  770.     Bind KPad-     prevWindow
  771.     Bind KPad0       pageBack
  772.     # Bind Enter   pageForward
  773.     Bind Enter       briefThing
  774.     Bind Kpad1     prevFunc
  775.     Bind Kpad3     nextFunc
  776.     Bind KPad.     endOfBuffer                 
  777.     Bind KPad5     exchangePointAndMark     
  778.     Bind KPad7     backwardDeleteWord         
  779.     Bind KPad9     deleteWord                 
  780.     
  781.     Bind Help       alphaHelp                     
  782.     Bind Home       beginningOfBuffer             
  783.     Bind End        endOfBuffer                 
  784.     Bind Pgup       pageBack                     
  785.     Bind Pgdn       pageForward                  
  786.     Bind Del        deleteChar                 
  787.     Bind 0x33        backSpace
  788. }
  789.  
  790. ## 
  791.  # -------------------------------------------------------------------------
  792.  # 
  793.  # "alpha::keyBindings" --
  794.  # 
  795.  #  Bind some 'standard' alpha key-bindings
  796.  # -------------------------------------------------------------------------
  797.  ##
  798. proc alpha::keyBindings {} {
  799.     Bind Del    <z> forwardDeleteWhitespace
  800.     Bind 0x33   <z> forwardDeleteWhitespace
  801.     Bind Del        deleteChar
  802.     Bind 0x33        backSpace
  803.     Bind 0x33 <sz> forwardDeleteUntil
  804.     
  805.     Bind 't' <z>     insertToTop        
  806.     Bind 'z' <z>     pageBack
  807.     Bind '\ ' <z>     setMark
  808.     Bind '1' <z>    execAbbrev
  809.  
  810.     # Another control prefix.
  811.     Bind 'q' <z>     prefixChar
  812.     Bind 't' <Q>    shrinkHigh
  813.     Bind 'b' <Q>    shrinkLow
  814.     Bind 'l' <Q>    shrinkLeft
  815.     Bind 'r' <Q>    shrinkRight
  816.     Bind 'c' <Q>    chooseAWindow
  817.     Bind 'h' <Q>    winhorizontally
  818.     Bind 'i' <Q>    iconify
  819.     Bind 'n' <Q>    nextWindow
  820.     Bind 'o' <Q>    bufferOtherWindow
  821.     Bind 'p' <Q>    prevWindow
  822.     Bind 's' <Q>    swapWithNext
  823.     Bind 'a' <Q>    wintiled
  824.     Bind 'v' <Q>    winvertically
  825.     Bind 'f' <Q>    shrinkFull
  826.     Bind '2' <Q>    splitWindow
  827.     
  828.     Bind '\ ' <o>    oneSpace
  829.     Bind Esc    startEscape
  830.     Bind 'f' <cz>     freeMem
  831.     Bind 'h' <z>    hiliteWord
  832.     
  833.     Bind 'm' <X>    matchingLines 
  834.     Bind 's' <ze> regIsearch
  835.     Bind 'l' <C> dividingLine
  836.     
  837.     # global binding for CR
  838.     Bind '\r'       bind::CarriageReturn
  839.     Bind   F1         bind::Completion     
  840.     Bind '\[' <zs>  normalLeftBrace
  841.     Bind '\]' <zs>  normalRightBrace
  842.     # Useful for C-like-modes
  843.     Bind '\;'      bind::electricSemi
  844.     Bind '\;' <z> "insertText {;}"
  845.     Bind 'l' <z> centerRedraw
  846.     Bind 'l' <oz> refresh
  847. }
  848.  
  849.  
  850.  
  851.  
  852.  
  853.  
  854.